Optional Blocks.f

{
Currently used by:
  Motifs
  Tasks

\ NOTE: Careful that you don't define two properties of the same name that are different
   datatypes.

This is in evaluation.  All words in this file should be considered internal except:

POOL,
POOL:
BLK
GENERATE[
>[
]>
].
DISPOSE]
PROPERTY

}

Requires SORA\Buffers
Requires Stacks
Requires Tools

Only Forth Definitions

\ 0 Value last-pool-buffer

: pool,   ( /allocation count addr -- <name> )
   here locals| s |  over stack,
   swap 0 do   dup s push   over +   loop 2drop ;

: Pool:   ( /allocation count addr -- <name> )
   create   pool, ;

variable blk
256 Stack: blks
0 Value ^property-counter


[undefined] block-size [if] 512 constant block-size [then]
[undefined] blocks-maximum [if] 2000 constant blocks-maximum [then]
block-size  blocks-maximum  *  Buffer: block-buffer
block-size  blocks-maximum  block-buffer  Pool: blocks

: block   block-size * block-buffer + ;


: /block   block-size ;

:macro block-base    block-buffer ;


: ?full  ^property-counter @ block-size > abort" Block size exceeded with property; increase block-size in config.f or decrease number of properties defined in current block-type." ;

: no-redefinitions?
   warning @ $ffff and ;

: property   ( size addr-holder -- <name> )
   no-redefinitions? if
      >in @    defined if cr >name count type ."  exists, cancelling property definition"  drop 2drop exit then   drop  >in !
   then
   create , ^property-counter @ , ^property-counter +! immediate ?full
   does> state @ if @+ postpone literal postpone @ @ postpone literal postpone + else @+ @ swap @ + then ;

: Block-type:
   create here to ^property-counter  0 , does> to ^property-counter ;

\ "block-in"
\ : <<   blk @ blks push  blk ! ;
icode <<
   blk [u] push
   ebx blk [u] mov
   pop(ebx)
   ret end-code

: <<
   state @ if postpone << else blk ! then ; immediate

\ : >>   blks pop blk ! ;
icode >>
   blk [u] pop
   ret end-code

: >>
   state @ if postpone >> then ; immediate

: generate   blocks pop ;
: dispose    blocks push ;
